Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume10/comobj.lisp/part11

Text File | 1987-08-02 | 39.3 KB | 1,574 lines

Path: uunet!rs
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v10i085:  Common Objects, Common Loops, Common Lisp, Part11/13
Message-ID: <[e-mail]>
Date: 3 Aug 87 21:18:58 GMT
Organization: UUNET Communications Services, Arlington, VA
Lines: 1563
Approved: [e-mail]

Submitted-by: Roy D'Souza <[e-mail]>
Posting-number: Volume 10, Issue 85
Archive-name: comobj.lisp/Part11

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 11 (of 13)."
# Contents:  co-dtype.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'co-dtype.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'co-dtype.l'\"
else
echo shar: Extracting \"'co-dtype.l'\" \(36944 characters\)
sed "s/^X//" >'co-dtype.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File:         co-dtype.l
X; RCS:          $Revision: 1.1 $
X; SCCS:         %A% %G% %U%
X; Description:  CommonObjects types.
X; Author:       James Kempf
X; Created:      March 10, 1987
X; Modified:     12-Mar-87 09:58:43 (James Kempf)
X; Language:     Lisp
X; Package:      COMMON-OBJECTS
X; Status:       Distribution
X;
X; (c) Copyright 1987, HP Labs, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted.  Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; [e-mail]
X
X;;;-*-Mode:LISP; Package:(CO (PCL LISP)); Base:10; Syntax: Common-lisp-*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X
X(in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  Define-Type
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;define-type-Define a CommonObjects type
X
X(defmacro define-type (&rest body)
X
X     (internal-define-type body)
X
X) ;end define-type
X
X;;internal-define-type-Parse a CommonObjects type definition and
X;;  generate code for creating the type.
X
X(defun internal-define-type (body)
X
X   (let
X     (
X       (doc-string NIL) ;;documentation string, if any
X       (name NIL)    ;;type name
X       (parents NIL)    ;;list of parents
X       (slots   NIL)    ;;list of instance variables
X       (options NIL)    ;;options list
X       (phonytiv NIL)    ;;phony type info vector. Used to
X                        ;;  hold type definition during
X                        ;;  parsing.
X       (assignments NIL);;variable initializations
X       (settables NIL)    ;;settable method names
X       (gettables NIL)    ;;gettable method names
X       (inherited NIL)    ;;inherited methods w. parents
X       (keywords NIL)   ;;keywords for initialization
X       (init-key-check  ;;T if a check should occur
X        NIL
X       )
X       (dont-define NIL)  ;;methods to not define
X     )
X
X
X     ;;Get name and options
X
X     (multiple-value-setq
X      (name doc-string options)
X        (co-parse-define-type-call (cons 'define-type body)
X                   name doc-string options
X        )
X     )
X
X     ;;Make a phony type info for use with options parsing code
X
X     (setf phonytiv (build-phony-type-info name))
X
X     ;;Get variable names, assignments, and other options
X
X     (multiple-value-setq
X      (slots assignments options)
X      (co-process-var-options phonytiv options slots assignments)
X     )
X
X     ;;Fill in phony type info with option information
X
X     (co-parse-options phonytiv slots options)
X
X     (setf parents (svref phonytiv $PARENT-TYPES-SLOT))
X
X     (setf gettables (svref phonytiv $GETTABLE-VARIABLES-SLOT))
X     (setf settables (svref phonytiv $SETTABLE-VARIABLES-SLOT))
X     (setf inherited (svref phonytiv $METHODS-TO-INHERIT-SLOT))
X     (setf init-key-check
X    (not (svref phonytiv $NO-INIT-KEYWORD-CHECK-SLOT))
X     )
X     (setf dont-define
X       (svref phonytiv $METHODS-TO-NOT-DEFINE-SLOT)
X     )
X
X     ;;Make keywords out of initiable variables and merge with
X     ;;  keywords
X
X     (setf keywords
X           (append
X         (svref phonytiv  $INIT-KEYWORDS-SLOT)
X             (mapcar
X               #'(lambda (x)
X                 (intern (symbol-name x) (find-package 'keyword))
X               )
X               (svref phonytiv $INITABLE-VARIABLES-SLOT)
X             )
X           )
X
X    ) ;setf
X
X    ;;All compile-time checking must be done BEFORE the compile-time
X    ;;  class definition is done, so that errors don't leave
X    ;;  around a bogus class.
X
X    ;;Merge duplicate method names and check for inheritance
X    ;;  funny business
X
X    (merge-duplicates name gettables settables inherited dont-define)
X
X     ;;Fully define the class at compile-time, so that
X     ;;  method definition works. Note that this means that
X     ;;  any pre-existing definition will be clobbered.
X     ;;  Compile time definition is needed for
X     ;;  any other methods which are defined in the same
X     ;;  file as a type definition. This is necessary because
X     ;;  the metaobject protocol doesn't distinguish between
X     ;;  a partially defined type and a fully defined one.
X     ;;  Compile-time definition is no longer needed for
X     ;;  definition of inherited, universal, and get/set
X     ;;  methods, since the metaobject protocol is gone
X     ;;  around for these, except for the :INITIALIZE-VARIABLES
X     ;;  method, which is still generated in full.
X
X     (fully-define-type name slots parents keywords init-key-check)
X
X     ;;Generate code for the class definition. This code
X     ;;  defines the class at load time and the universal
X     ;;  methods.
X
X    `(progn
X
X       ;;This only needs to get done at load time, since
X       ;;  class definition at compile time (to take
X       ;;  care of :INITIALIZE-VARIABLES method generation
X       ;;  and others in the file) is done during the macro
X       ;;  expansion. Also, it need not get done if the
X       ;;  definition is being evaluated, since the macro
X       ;;  has already done in.
X
X       (eval-when (load)
X     (fully-define-type ',name
X                    ',slots
X                ',parents
X                ',keywords
X                ',init-key-check
X     )
X       )
X
X        ;;Define the initialization, get/set, and inherited methods.
X
X        ;;Variable initialization is handled by generating an
X        ;;  initialization method. The :INITIALIZE-VARIABLES method
X        ;;  is the only universal one  generated on a type by type basis.
X        ;;  Since the user can insert anything into the initialization
X        ;;  forms, the code must go through the full processing
X        ;;  for method definition, including code walking of
X        ;;  WITH-SLOTS. This requires that the PCL class be
X        ;;  defined at compile time.
X
X        ,(if (not (member ':initialize-variables dont-define))
X          (build-init-vars-method
X            name
X            (svref phonytiv $INITABLE-VARIABLES-SLOT)
X        assignments
X          )
X        )
X
X    ;;Universal methods are no longer defined on a per type
X        ;;  basis, but rather default methods are defined
X        ;;  for all CommonObjects types. The user can define
X    ;;  their own methods which override the default ones,
X    ;;  but the defaults can't be undefined or renamed.
X    ;;  Using defaults saves time during type definition.
X
X        ;;Inherited methods  must be defined
X        ;;  at compile time, otherwise the CLASS-DIRECT-METHODS
X        ;;  call in METHOD-ALIST won't find the gettable and
X        ;;  settable methods during compilation. This is
X        ;;  also true for gettable and settable methods.
X        ;;  Note, however, that other methods defined in
X        ;;  the same file will NOT get inherited, because
X        ;;  they are not fully defined at compile time.
X        ;;  This means that users should avoid defining
X        ;;  parent and child types in the same file.
X        ;;  In particular, the ADD-METHOD call generated
X        ;;  by the PCL method generation code only gets
X        ;;  done at load time, and hence seperately defined
X        ;;  methods are only returned by CLASS-DIRECT-METHODS
X        ;;  after loading. The code below  will cause the
X        ;;  (EVAL-WHEN (LOAD) ...) top level forms returned
X        ;;  by the PCL method code generation to be overridden.
X
X
X          ;;Inherited methods
X
X          ,@(build-inherited-methods name inherited dont-define parents slots)
X
X          ;;Gettables and settables
X
X      ,@(build-gs-methods name gettables settables dont-define parents slots)
X
X          ',name
X
X       ) ;progn
X
X
X  ) ;end let
X) ;end internal-define-type
X
X;;fully-define-type-Fully define the CommonObjects type
X
X(defun fully-define-type (name slots parents keywords init-key-check)
X
X  (let
X    (
X      (classprot (class-prototype (class-named 'common-objects-class)))
X    )
X
X    ;;Check for redefinition incompatibility, if any.
X
X    (check-for-redefinition-incompatibility name parents slots)
X
X    (add-named-class classprot
X             name
X             parents
X             slots
X             NIL
X    )
X
X
X    ;;Now set the slots for the initialization keywords and
X    ;;  the check flag
X
X    (setf classprot (class-named name))
X    (setf (class-init-keywords classprot) keywords)
X    (setf (class-init-keywords-check classprot) init-key-check)
X
X  ) ;let
X
X) ;end fully-define-type
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  Auxillary Type Definition Functions
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;build-phony-type-info-Make a phony type info vector, to hold the
X;;  information while the DEFINE-TYPE call is being parsed.
X
X(defun build-phony-type-info (name)
X
X;;Check if the name is OK first
X
X  (unless (co-legal-type-or-method-name name)
X    (co-deftype-error "legal type names must be symbols and NOT the symbol NIL."
X      name
X    )
X  )
X
X  ;;Set the name and origin slots and return
X
X  (let
X    (
X      (phonytiv
X    (make-array
X      $INFO-NUMBER-OF-SLOTS
X      :initial-element NIL
X        )
X      )
X    )
X
X    (setf (svref phonytiv $TYPE-NAME-SLOT) name)
X
X    phonytiv
X
X    ;;Note that we don't check for predefined type info's here
X    ;;  because that should (eventually!) be handled by
X    ;;  the CommonLoops kernel
X
X  ) ;end let
X
X) ;end build-phony-type-info
X
X;;check-for-redefinition-incompatibility-Check to see if redefining
X;;  will cause an incompatible change
X
X(defun check-for-redefinition-incompatibility (name newparents newslots)
X
X  (let*
X    (
X      (oldclass (class-named name T))
X    )
X
X
X    ;;If no class object, then this is new
X
X    (when oldclass
X
X      ;;Check instance variable incompatibility
X
X      (if (not (slots-compatible-p newslots (class-user-visible-slots oldclass)))
X        (co-deftype-error
X        "please rename, since changing instance variables is incompatible.~%"
X        name
X        )
X      )
X
X      ;;Check for parent incompatibility
X
X      (if (not
X        (slots-compatible-p
X          newparents
X          (class-local-super-names oldclass)
X            )
X          )
X        (co-deftype-error
X        "please rename, since changing parents is incompatible.~%"
X        name
X        )
X      )
X
X    ) ;when
X
X  ) ;let
X
X) ;end check-for-redefinition-incompatibility
X
X;;slots-compatible-p-Check if the number and ordering
X;;  of the slots in the old and new lists is the same
X
X(defun slots-compatible-p (newslots oldslots)
X
X  ;;Check that number of slots is the same
X
X  (when (not (= (length oldslots) (length newslots)))
X    (return-from slots-compatible-p NIL)
X  )
X
X  ;;Check slot names
X
X  (do
X    (
X      (ns newslots (cdr ns))
X      (os oldslots (cdr os))
X    )
X    ( (or (null ns) (null os)) )
X
X    (if (not (eq (car ns) (car os)))
X      (return-from slots-compatible-p NIL)
X    ) ;if
X  ) ;do
X
X  T
X) ;end slots-compatible-p
X
X;;merge-duplicates-Merge duplicates and check for conflicts
X;;   in parents.
X
X(defun merge-duplicates (name gettables settables parents dont-define)
X
X  ;;Destructively modify gettables and settables
X  ;;to get rid of duplicates
X
X  (merge-methods gettables settables)
X
X  ;;Check for funny business in inheritance
X
X  (check-for-funny-inheritance name parents)
X
X  ;;Check if any conflicts with parents and among parents
X
X  (check-for-method-conflicts name gettables parents dont-define)
X
X  NIL
X) ;end merge-duplicates
X
X;;merge-methods-Put settables on gettable list
X
X(defun merge-methods (gettables settables)
X
X  (dolist (meth settables)
X
X    (when (not (member meth gettables :test #'equal))
X      (setf (cdr (last gettables)) (list meth ) )
X    )
X  ) ;dolist
X
X) ;end merge-methods
X
X;;check-for-funny-inheritance-Check for attempts to inherit
X;;  from yourself
X
X(defun check-for-funny-inheritance (name parents)
X
X  ;;Check me
X
X  (dolist (p parents)
X
X    ;; Check me
X
X    (if (eq name (class-name (car p)))
X      (co-deftype-error"this type has itself as an ancestor.~%" name)
X    )
X
X    ;;Check parent
X
X    (check-for-funny-inheritance name (mapcar #'list (class-local-supers (car p))))
X  )
X
X) ;end check-for-funny-inheritance
X
X;;check-for-method-conflicts-Merge gettable and parent lists and
X;;  check for conflicts.
X
X(defun check-for-method-conflicts (name gettables parents dont-define)
X
X  (let
X    (
X      (kwp (find-package 'keyword))
X      (meths NIL)
X    )
X
X    ;;Intern the gettable names in the keyword package
X
X    (dolist (g gettables)
X      (setf meths (cons (intern (symbol-name g) kwp) meths))
X    ) ;dolist
X
X    ;;Concatenate the parent methods onto the end
X
X    (dolist (p parents)
X
X      (setf meths
X    (concatenate
X      'list
X      meths
X      (cdr p)
X    )
X      )
X
X    ) ;dolist
X
X    ;;Now check for duplicates
X
X    (check-for-conflicts name meths dont-define)
X
X  ) ;let
X
X) ;end check-for-method-conflicts
X
X;;check-for-conflicts-Check if any generated methods
X;;  conflict
X
X(defun check-for-conflicts (name list dont-define)
X
X    (setf list (sort list #'(lambda (x y) (string-lessp (symbol-name x) (symbol-name y)))))
X
X    (do*
X      (
X        (item (car list) (car clist))
X        (clist (cdr list) (cdr clist))
X      )
X      ((eq clist NIL))
X
X      ;;Check if a method already exists and isn't on the don't define
X      ;;  list
X
X      (if (and (equal item (car clist)) (not (member item dont-define)))
X        (co-deftype-error
X      "two methods ~S exist during method generation.~%~
X           Please undefine one or the other.~%"
X      name item
X        )
X      )
X    ) ;do
X
X) ;end check-for-conflicts
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  Top Level Method Building Functions
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;build-inherited-methods-Build the list of inherited methods by using
X;;  apply-method
X
X(defun build-inherited-methods (name parents dont-define parent-names slots)
X
X  (let
X    (
X      (methcode NIL)
X    )
X
X    ;;Do all the parents
X
X    (dolist (p parents)
X
X      ;;Do this parent's list
X
X      (dolist (m (cdr p))
X
X        ;;Check first to be sure it should be defined
X
X        (if (not (member m dont-define))
X
X      (push
X            (build-inherited-method
X              name
X              m
X              (class-name (car p))
X              parent-names
X              slots
X            )
X            methcode
X          )
X
X        )
X
X      ) ;dolist
X    ) ;dolist
X
X    methcode
X
X  ) ;let
X
X) ;build-inherited-methods
X
X;;build-gs-methods-Build gettable and settable methods
X
X(defun build-gs-methods (typename gettables settables dont-define parents slots)
X
X  (let
X    (
X      (methcode NIL)
X      (kwp (find-package 'keyword))
X      (meth NIL)
X    )
X
X    ;;First do gettables
X
X    (dolist (g gettables)
X
X      (setf meth (intern (symbol-name g) kwp))
X
X      ;;Check first to be sure it must be defined
X
X      (if (not (member meth dont-define))
X
X        (push
X          (build-get-method typename
X                            meth
X                            g
X                            parents
X                            slots
X           )
X          methcode
X        )
X      )
X
X
X    ) ;dolist
X
X    ;;Now do settables
X
X    (dolist (s settables)
X
X      (setf meth
X            (intern (concatenate 'simple-string "SET-" (symbol-name s)) kwp)
X      )
X
X      ;;Check first to be sure it must be defined
X
X      (if (not (member s dont-define))
X        (push
X      (build-set-method
X        typename
X            meth
X        s
X            parents
X            slots
X          )
X      methcode
X        )
X      )
X
X    ) ;dolist
X
X    methcode
X
X  ) ;let
X) ;end build-gs-methods
X
X;;build-init-vars-method-Return code for the :INITIALIZE-VARIABLES
X;;  method. Note that this must be a fully-blown CommonObjects
X;;  method, because the users can put anthing they want into
X;;  the initialization code, including CALL-METHOD.
X
X(defun build-init-vars-method
X  (name initable-slots assignments)
X
X  (let
X    (
X      (form NIL)
X      (kwpak (find-package 'keyword))
X      (code NIL)
X    )
X
X
X    ;;This code is stolen from DEFINE-METHOD and is
X    ;;  inserted in line here so that, when it
X    ;;  gets returned to the top level, PCL::EXPAND-DEFMETH-INTERNAL
X    ;;  gets invoked while the DEFINE-TYPE macro is executing,
X    ;;  rather than at the top level, when the macro has
X    ;;  finished executing.
X
X    (setf code
X      `(compiler-let
X        (
X          (*current-method-class-name* ',name)
X        )
X
X
X        (let ((self (self-from-inner-self)))
X           (declare (optimize (speed 3) (safety 0)))
X
X          (with*
X            (
X              (.inner-self. "" ,name)
X            )
X
X            ,(if initable-slots
X
X              `(do*
X                (
X              (unprocessed-keys keylist (cddr unprocessed-keys))
X              (keyword (car unprocessed-keys) (car unprocessed-keys))
X              (value (cadr unprocessed-keys) (cadr unprocessed-keys))
X                )
X                ( (null unprocessed-keys) )
X                (case keyword
X                ,@(dolist (var initable-slots form)
X                  (push
X                        `(
X                          (,(intern (symbol-name var) kwpak) )
X                          (setf ,var value)
X                        )
X                form
X                      )
X                )
X                  )
X              )
X
X           ) ;if
X
X            ,@assignments
X
X          ) ;with*
X
X      ) ;let
X      ) ;compiler-let
X    ) ;setf
X
X    ;;Now define as a full blown CommonObjects method, with code
X    ;; walking and everything. Add in CALL-METHOD processing.
X
X    `(progn
X
X      ,(defcommon-objects-meth
X        'keyword-standin::initialize-variables
X        `((.inner-self. ,name) &rest keylist)
X        code
X      )
X
X     ) ;progn
X
X   ) ;end let
X
X) ;end build-init-vars-method
X
X;;build-pcl-method-def-Build a PCL method definition without
X;; all the overhead of code walking and method object creation
X;; at compile time
X
X(defun build-pcl-method-def (type method func-args code)
X
X  (setf method
X        (if (keywordp method)
X            (keyword-standin method)
X            method
X        )
X  )
X
X  (let*
X    (
X      (type-spec (list type))
X      (method-function-name (pcl::make-method-name method type-spec))
X    )
X
X    ;;The extra list is so the forms get inserted at the
X    ;;  top level OK
X
X   `(
X     (eval-when (compile load eval)
X       (pcl::record-definition
X         ',method 'pcl::method ',type-spec NIL
X       )
X       (defun ,method-function-name ,func-args
X         (declare (optimize (speed 3) (safety 0)))
X    ,code
X       )
X     )
X
X     ;;Note that this must be done at compile time
X     ;;  as well, since inherited methods must
X     ;;  be there for other types in the file
X
X     (eval-when (compile load eval)
X       (let
X         (
X           (method
X             (pcl::load-method-1
X               'pcl::discriminator
X               'common-objects-method
X               ',method
X               ',type-spec
X               ',func-args
X               NIL
X             )
X
X           )
X
X        )
X
X        (setf (method-function method)
X              (symbol-function ',method-function-name)
X        )
X
X        (add-method (discriminator-named ',method) method NIL)
X      )
X
X    )
X
X   )
X
X  ) ;let*
X
X) ;build-pcl-method-def
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Get/Set and Inherited Method Building Functions
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;build-get-method-Build a gettable method
X
X(defun build-get-method (name methname var parents slots)
X
X  `(progn
X    ,@(build-pcl-method-def
X      name
X      methname
X      '(.inner-self.)
X      `(%instance-ref .inner-self. ,(calculate-slot-index var parents slots))
X    )
X  )
X
X) ;end build-get-method
X
X;;build-set-method-Build a settable method
X
X(defun build-set-method (name methname var parents slots)
X
X  `(progn
X    ,@(build-pcl-method-def
X      name
X      methname
X      '(.inner-self. .new-value.)
X      `(setf
X        (%instance-ref .inner-self. ,(calculate-slot-index var parents slots))
X        .new-value.
X       )
X    )
X  )
X
X) ;end build-set-method
X
X;;build-inherited-method-Return code for an inherited method.
X
X(defun build-inherited-method (name m p parents slots)
X
X  ;;Now generate code
X
X  `(progn
X    ,@(build-pcl-method-def
X        name
X        m
X        '(.inner-self. &rest .arg-list.)
X        `(apply
X        (symbol-function
X              ',(generate-method-function-symbol
X               p m
X                )
X        )
X            (%instance-ref
X          .inner-self.
X          ,(calculate-slot-index
X            p
X            parents
X                slots
X              )
X           )
X       .arg-list.
X
X         )
X      )
X
X  )
X
X) ;end build-inherited-method
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Default Universal Methods
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;define-universal-method-Macro to define universal methods. Note that
X;;  DEFCOMMON-OBJECTS-METH could probably be used directly, but this
X;;  tells what we're doing. We need a CommonObjects method here because
X;;  we may need a symbol for CALL-METHOD
X
X(defmacro define-universal-method (name arglist &body body)
X
X   ;;Check for undefined type in body
X
X    (setf body
X      `(progn
X        (if (eq (class-name (class-of ,(first (first arglist))))
X                $UNDEFINED-TYPE-NAME
X            )
X             (no-matching-method (discriminator-named ',name))
X        )
X        ,@body
X      )
X    )
X
X  (defcommon-objects-meth name arglist body)
X
X ) ;define-universal-method
X
X;;keyword-standin::init-Default :INIT method does nothing
X
X(define-universal-method keyword-standin::init
X  ((self common-objects-class) &rest keylist)
X
X
X) ;keyword-standin::init
X
X;;keyword-standin::initialize-Default :INITIALIZE initializes
X;;  parents, then variables
X
X(define-universal-method keyword-standin::initialize
X  ((self common-objects-class) &rest keylist)
X
X    (let
X      (
X        (class (class-of self))
X      )
X
X      (dolist (l (class-local-super-slot-names class))
X
X        ;;GET-SLOT is inserted in-line here
X
X        (apply 'keyword-standin::initialize
X          (%instance-ref self (slot-index class l))
X          keylist
X        )
X      )
X
X      ;;Now initialize variables
X
X      (apply 'keyword-standin::initialize-variables self (car keylist))
X      (apply 'keyword-standin::init self (car keylist))
X
X  ) ;let
X
X) ;keyword-standin::initialize
X
X;;print-instance-Print the instance
X
X(define-universal-method print-instance
X  ((self common-objects-class) output-stream integer)
X
X  (if (or (not integer)
X          (not *print-level*)
X          (< integer *print-level*)
X      )
X
X      (pcl::printing-random-thing (self output-stream)
X    (format output-stream  "~A" (class-name (class-of self)))
X      )
X
X  )
X
X) ;print-instance
X
X;;keyword-standin::describe-Default :DESCRIBE method
X
X(define-universal-method keyword-standin::describe
X  ((self common-objects-class) &optional describe-inner-loop)
X
X  (let
X    (
X      (class (class-of self))
X    )
X
X    (when (equal
X            (class-name (class-of class))
X            'common-objects-class
X           )
X
X      ;;Give name of this guy
X
X      (if (not describe-inner-loop)
X        (format T
X            "This object of type ~A has variables:~%"
X            (class-name (class-of self))
X        )
X        (format T
X                "For parent ~A:~%"
X            (class-name (class-of self))
X        )
X      ) ;if
X
X      ;;Now print instance variables
X
X      (dolist (slot (class-user-visible-slots class))
X        (format T "    ~A: ~S~%" slot (get-slot-using-class class self slot))
X      )
X
X      ;;Now print for parents
X
X      (dolist (lss (class-local-super-slot-names class))
X        (keyword-standin::describe (get-slot-using-class class self lss) T)
X      )
X
X    ) ;when
X
X  ) ;let
X
X) ;keyword-standin::describe
X
X;;keyword-standin::eql-Default :EQL predicate method
X
X(define-universal-method keyword-standin::eql
X  ((self common-objects-class) .any.)
X
X      (eq self .any.)
X
X) ;keyword-standin::eql
X
X;;keyword-standin::equal-Default :EQUAL predicate method
X
X(define-universal-method keyword-standin::equal
X  ((self common-objects-class) .any.)
X
X   (keyword-standin::eql self .any.)
X
X) ;keyword-standin::equal
X
X;;keyword-standin::equalp-Default :EQUALP predicate method
X
X(define-universal-method keyword-standin::equalp
X  ((self common-objects-class) .any.)
X
X  (keyword-standin::equal self .any.)
X
X) ;keyword-standin::equalp
X
X;;keyword-standin::typep-Default :TYPEP predicate method
X
X(define-universal-method keyword-standin::typep
X  ((self common-objects-class) .any.)
X
X  (or (equal (class-name (class-of self)) .any.)
X      (eq .any. 'instance)
X      (eq .any. 't)
X  )
X
X) ;keyword-standin::typep
X
X;;keyword-standin::copy-Default :COPY method
X
X(define-universal-method keyword-standin::copy
X  ((self common-objects-class))
X
X      self
X
X) ;keyword-standin::copy
X
X;;keyword-standin::copy-instance-Default :COPY-INSTANCE method
X
X(define-universal-method keyword-standin::copy-instance
X  ((self common-objects-class))
X
X  (let
X    (
X      (class (class-of self))
X      (inst NIL)
X    )
X
X    (when (equal
X            (class-name (class-of class))
X            'common-objects-class
X           )
X
X      (setf inst (make-instance (class-name class)))
X
X      ;Copy state from inner-self to instance
X
X      (co::set-slot-values self inst class)
X
X      inst
X   ) ;when
X
X  ) ;let
X
X) ;keyword-standin::copy-instance
X
X;;keyword-standin::copy-state-Default :COPY-STATE method
X
X(define-universal-method keyword-standin::copy-state
X  ((self common-objects-class))
X
X      self
X
X) ;keyword-standin::copy-state
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  Support Methods and Functions for Universal Methods
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;set-slot-values-Set the slot values in OBJECT to those in .INNER-SELF.
X
X(defmeth set-slot-values (.inner-self. object class)
X
X  ;;Set in this guy
X
X  (dolist (slot (class-user-visible-slots class))
X    (setf (get-slot object slot) (get-slot .inner-self. slot))
X  )
X
X  ;;Now set in parents
X
X  (dolist (lss (class-local-super-slot-names class))
X      (set-slot-values
X    (get-slot .inner-self. lss)
X    (get-slot object lss)
X    (class-of (get-slot .inner-self. lss))
X      )
X  )
X
X) ;end set-slot-values
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  Renaming and Undefining Types and Methods
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;rename-type-Rename type1 to type2
X
X(defun rename-type (type1 type2)
X  (declare (type symbol type1 type2))
X
X  (let
X    (
X      (class (class-named type1 T))
X      (newclass (class-named type2 T))
X    )
X
X    ;;Signal an error for special cases
X
X    (when (or (null type2) (eq type2 't))
X      (error "RENAME-TYPE: New name cannot be NIL or T.~%")
X    )
X
X    ;;Signal an error when arguments aren't symbols
X
X    (when (or (not (symbolp type1)) (not (symbolp type2)))
X      (error "RENAME-TYPE: Arguments must be symbols.~%")
X    )
X
X    ;;Signal error if TYPE2 already exists
X
X    (when newclass
X      (error "RENAME-TYPE: Type ~S already exists.~%" type2)
X    )
X
X    ;;Signal an error if class isn't CommonObjects class
X
X    (when (not (eq (class-name (class-of class)) 'common-objects-class))
X      (error "RENAME-TYPE: Can't rename a built-in type or nonCommonObjects class ~S.~%" type1)
X    )
X
X    ;;Signal an error if the class is not defined
X
X    (if class
X      (progn
X    (rename-class class type2)
X        type2
X
X      ) ;progn
X      (error "RENAME-TYPE: The type ~S is not defined.~%" type1)
X    ) ;if
X
X  ) ;let
X
X) ;end rename-type
X
X;;undefine-type-Undefine type typename
X
X(defun undefine-type (typename)
X  (declare (type symbol typename))
X
X  ;;Check if typename is a symbol
X
X  (when (not (symbolp typename))
X    (error "UNDEFINE-TYPE: Argument must be a symbol.~%")
X  )
X
X  (let
X    (
X     (class (class-named typename T))
X    )
X
X    (if (and class (eq (class-name (class-of class)) 'common-objects-class))
X     (progn
X
X        ;;Undefine all the methods first
X
X        (undefine-methods class)
X
X        ;;Now set the class name
X
X        (setf (class-name class) $UNDEFINED-TYPE-NAME)
X    (setf (class-named typename) NIL)
X        T
X      ) ;progn
X
X      NIL
X
X    ) ;if
X
X  ) ;let
X
X) ;end undefine-type
X
X;;undefine-methods-Undefine all the methods on class
X
X(defun undefine-methods (class)
X
X  (dolist (meth (class-direct-methods class))
X
X    ;;Remove the method from the discriminator
X
X    (remove-method (method-discriminator meth) meth)
X
X    ;;Now unbind the symbol cell, so call-methods don't work
X
X    (fmakunbound (method-function-symbol meth))
X  )
X
X) ;undefine-methods
X
X;;undefine-method-Use PCL remove-method to get
X;;  rid of method.
X
X(defun undefine-method (typename operation)
X  (declare (type symbol typename operation))
X
X  ;;Check if the arguments are symbols
X
X  (when (not (symbolp typename))
X    (error "UNDEFINE-METHOD: Type name must be a symbol.~%")
X  )
X
X  ;;If the operation is not a symbol, just return.
X
X  (when (not (symbolp operation))
X    (return-from undefine-method NIL)
X  )
X
X  (let*
X    (
X
X      ;;The class object
X
X      (class (class-named typename))
X
X      ;;The operation
X
X      (opname (if (keywordp operation)
X                (keyword-standin operation)
X                operation
X              )
X      )
X
X      ;;The discriminator (if any)
X
X      (disc (discriminator-named opname))
X
X      ;;The method (if any)
X
X      (meth
X        (if disc
X          (find-method disc (list typename) NIL T)
X        )
X      )
X
X    )
X
X
X    ;;Check if the class is a CommonObjects class
X
X    (when (not (eq (class-name (class-of class)) 'common-objects-class))
X      (error "UNDEFINE-TYPE: Tried to undefine ~S ~
X              which is not a CommonObjects class.~%"
X              typename
X      )
X    )
X
X    ;;Check if the method is a universal method and there
X    ;; is no type specific method. Warn the user.
X
X    (when (and
X            (null meth)
X            (member operation *universal-methods* :test #'eq)
X          )
X      (warn
X        (format
X          NIL
X          "UNDEFINE-TYPod NIL)
X  )
X
X  (let*
X    (
X
X      ;;The class ob% which cannot be undefined."
X      typename
X          operation
X        )
X      )
X      (return-from undefine-method NIL)
X    )
X
X    ;;If a method was found, undefine it
X
X    (if (and meth disc)
X      (progn
X    (remove-method disc meth)
X
X        ;;Now unbind the symbol cell, so CALL-METHODs don't work
X
X    (fmakunbound (method-function-symbol meth))
X
X        ;;Remove the symbol from the package, so that future
X    ;;  attempts to create CALL-METHODs can't find it.
X    ;;  But hopefully, existing CALL-METHODs will still
X        ;;  work.
X
X        (unintern (method-function-symbol meth)
X           (symbol-package (method-function-symbol meth))
X        )
X
X        T
X      ) ;progn
X
X      NIL
X
X    ) ;if
X
X  ) ;let
X
X) ;end undefine-method
X
X;;assignedp-Indicate whether or not an instance variable is
X;;  assigned
X
X(defmacro assignedp (var)
X
X  (declare (special co::*current-method-class-name*))
X
X  ;;Check for attempt to access outside of a method
X
X  (if (null (boundp 'co::*current-method-class-name*))
X    (error "DEFINE-METHOD: Attempt to use assignedp outside of a method.~%")
X  )
X
X  ;;Check for attempt to use on something other than an instance variable
X
X  (unless (has-slot-p (class-named *current-method-class-name*) var)
X    (error "DEFINE-METHOD: Argument ~S to assignedp ~
X           must be an instance variable name.~%"
X           var
X     )
X  )
X
X  `(not (equal ,var ',$UNINITIALIZED-VARIABLE-FLAG))
X
X) ;;end assignedp
X
X;;instancep-Return T if this thing is an instance and has a CommonObjects
X;;  class
X
X(defun instancep (thing)
X
X  ;;Check first if thing is NIL
X
X  (if (not thing)
X    NIL
X    (eq (class-name (class-of (class-of thing))) 'common-objects-class)
X  )
X
X
X) ;end instancep
X
X;;supports-operation-p-Return T if method operation METH is supported on type
X;;  of OBJ
X
X(defun supports-operation-p (obj meth)
X  (declare (special *universal-methods*))
X
X  (let
X    (
X      (class (if obj (class-of obj) obj))
X    )
X
X    ;;If not a CommonObjects class, then return NIL
X
X    (when (or (not class)
X              (not (eq (class-name (class-of class)) 'common-objects-class))
X          )
X      (return-from supports-operation-p NIL)
X    )
X
X    ;;Check first if its a universal method
X
X    (if (member meth *universal-methods*)
X
X      T
X
X      ;;Otherwise, check in the class object if it's got them
X
X      (dolist (methobj (class-direct-methods class))
X
X        (when (eq (unkeyword-standin (method-name methobj)) meth)
X          (return-from supports-operation-p T)
X        )
X
X      ) ;dolist
X
X    ) ;if
X
X  ) ;let
X
X) ;end supports-operation-p
X
X;;Define the instance type
X
X(deftype instance ()
X  (list 'apply 'instancep)
X
X) ;end deftype
X
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  Make-Instance
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;make-instance-Make an instance given the CommonObjects type name
X
X(defmeth make-instance ((class-name symbol) &rest keylist)
X
X    ;;Check if the key list and class are OK.
X
X    (if (null (listp keylist))
X      (error "Make-instance requires a list for the keyword list.~%")
X    )
X
X    (if (null (class-named class-name T))
X      (error "~S is not a defined type.~%" class-name)
X    )
X
X   (make-instance (class-named class-name) keylist)
X
X) ;end make-instance
X
X;;make-instance-Make an instance given the CommonObjects class object
X
X(defmeth make-instance ((class common-objects-class) &rest keylist)
X  (declare (special *outer-self*))
X
X  (let*
X    (
X      (instance NIL)
X      (numslots (length (class-user-visible-slots class)))
X      (start-slots
X    (+ $START-OF-PARENTS (length (class-local-supers class)))
X      )
X    )
X      (let
X    (
X          (*outer-self* (and (boundp '*outer-self*) *outer-self*))
X        )
X        (declare (special *outer-self*))
X
X        (setf instance (%make-instance (class-of class)
X                       (+ 2 (class-instance-size class))
X                       )
X        )
X        (setf (%instance-ref instance $CLASS-OBJECT-INDEX) class
X          (%instance-ref instance $SELF-INDEX) (or *outer-self*
X                                    (setq *outer-self* instance)
X                            )
X        )
X
X        ;;Initialize the slots with the uninitialized flag
X
X        (dotimes (i numslots)
X          (setf
X        (%instance-ref instance (+ i start-slots))
X            $UNINITIALIZED-VARIABLE-FLAG
X          )
X        )
X
X        ;;Now go through and make parent objects
X
X        (do
X          (
X            (supers (class-local-supers class) (cdr supers))
X        (index $START-OF-PARENTS (1+ index))
X          )
X      ((null supers))
X      (setf (%instance-ref instance index)
X            (make-instance (car supers) (car keylist))
X          )
X        ) ;do
X
X    ) ;end let for dynamic binding
X
X    ;;Check initialization keywords and initialize, but only if
X    ;;  creating outer self object.
X
X    (when (not (boundp '*outer-self*))
X
X      ;;If keyword check needed, then check keyword list
X
X      (if (class-init-keywords-check class)
X        (check-init-keywords class keylist)
X      )
X      ;;Now initialize, if doing outer self.
X
X      (keyword-standin::initialize instance (car keylist))
X
X    ) ;when
X
X    instance
X
X  ) ;end let for lexical binding
X
X) ;end make-instance
X
END_OF_FILE
if test 36944 -ne `wc -c <'co-dtype.l'`; then
    echo shar: \"'co-dtype.l'\" unpacked with wrong size!
fi
# end of 'co-dtype.l'
fi
echo shar: End of archive 11 \(of 13\).
cp /dev/null ark11isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 13 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--

Rich $alz            "Anger is an energy"
Cronus Project, BBN Labs    [e-mail]
Moderator, comp.sources.unix    [e-mail]